home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / c / num_log.c < prev    next >
Encoding:
C/C++ Source or Header  |  1987-06-04  |  16.7 KB  |  926 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     Logical operations on number
  9. */
  10. #include "include.h"
  11. #include "num_include.h"
  12.  
  13. /*
  14.     x : fixnum or bignum (may be not normalized)
  15.     y : integer
  16.    returns
  17.     fixnum or bignum ( not normalized )
  18. */
  19. object
  20. log_op(op)
  21. int (*op)();
  22. {
  23.     object x;
  24.     int    narg, i, j;
  25.     struct bignum *big_log_op();
  26.  
  27.     narg = vs_top - vs_base;
  28.     if (narg < 2) too_few_arguments();
  29.     i = narg;
  30.     while(--i >= 0)
  31.         if (type_of(vs_base[i]) == t_bignum) goto BIG_OP;
  32.     j = fix(vs_base[0]);
  33.     i = 1;
  34.     while (i < narg) {
  35.         j = (*op)(j, fix(vs_base[i]));
  36.         i++;
  37.     }
  38.     return(make_fixnum(j));
  39.  
  40. BIG_OP:
  41.     x = (object)copy_to_big(vs_base[0]);
  42.     vs_push(x);
  43.     i = 1;
  44.     while (i < narg) {
  45.         x = (object)big_log_op(x, vs_base[i], op);
  46.         i++;
  47.     }
  48.     x = normalize_big_to_object(x);
  49.     vs_pop;
  50.     return(x);
  51. }
  52. /*
  53.     big_log_op(x, y, op) performs the logical operation op onto
  54.     x and y, and return the result in x destructively.
  55. */
  56. struct bignum *
  57. big_log_op(x, y, op)
  58. struct bignum *x;
  59. object y;
  60. int (*op)();
  61. {
  62.     struct bignum *r;
  63.     int    sign_x, sign_y;
  64.     int    ext_x, ext_y;
  65.     int    end_x, end_y;
  66.     int    i, j;
  67.  
  68.     r = x;        /* remember start of x */
  69.     if (type_of(x) != t_bignum)
  70.         FEwrong_type_argument(Sbignum, x);
  71.     else if (big_sign(x) < 0) {
  72.         sign_x = ~MASK;
  73.         ext_x = MASK;
  74.          } else
  75.         sign_x = ext_x = 0;
  76.     if (type_of(y) == t_fixnum)
  77.         if (fix(y) < 0) {
  78.             sign_y = ~MASK;
  79.             ext_y = MASK;
  80.         } else
  81.             sign_y = ext_y = 0;
  82.     else if (type_of(y) == t_bignum)
  83.         if (big_sign(y) < 0) {
  84.             sign_y = ~MASK;
  85.             ext_y = MASK;
  86.         } else
  87.             sign_y = ext_y = 0;
  88.     else
  89.         FEwrong_type_argument(Sinteger, y);
  90.  
  91.     end_x = end_y = 0;
  92.     while ((end_x == 0) || (end_y == 0)) {
  93.         if (end_x == 0)
  94.             i = (x->big_car) & MASK;
  95.         else
  96.             i = ext_x;
  97.         if (end_y == 0)
  98.             if (type_of(y) == t_fixnum)
  99.                 j = (fix(y)) & MASK;
  100.             else
  101.                 j = (y->big.big_car) & MASK;
  102.         else
  103.             j = ext_y;
  104.         i = (*op)(i, j);
  105.         if (end_x == 0)
  106.             x->big_car = i & MASK;
  107.         else
  108.             x = stretch_big(x, i & MASK);
  109.         if (x->big_cdr != NULL)
  110.             x = x->big_cdr;
  111.         else
  112.             end_x = 1;
  113.         if (type_of(y) == t_fixnum)
  114.             end_y = 1;
  115.         else if (y->big.big_cdr != 0)
  116.             y = (object)y->big.big_cdr;
  117.         else
  118.             end_y = 1;
  119.     }
  120.     /* Now x points ths last sell of bignum.
  121.        We must set the sign bit according to operation.
  122.        Sign bit of x is already masked out in previous
  123.        while-iteration */
  124.     x->big_car |= ((*op)(sign_x, sign_y) & ~MASK);
  125.  
  126.     return(r);
  127. }
  128.  
  129. int
  130. ior_op(i, j)
  131. int    i, j;
  132. {
  133.     return(i | j);
  134. }
  135.  
  136. int
  137. xor_op(i, j)
  138. int    i, j;
  139. {
  140.     return(i ^ j);
  141. }
  142.  
  143. int
  144. and_op(i, j)
  145. int    i, j;
  146. {
  147.     return(i & j);
  148. }
  149.  
  150. int
  151. eqv_op(i, j)
  152. int    i, j;
  153. {
  154.     return(~(i ^ j));
  155. }
  156.  
  157. int
  158. nand_op(i, j)
  159. int    i, j;
  160. {
  161.     return(~(i & j));
  162. }
  163.  
  164. int
  165. nor_op(i, j)
  166. int    i, j;
  167. {
  168.     return(~(i | j));
  169. }
  170.  
  171. int
  172. andc1_op(i, j)
  173. int    i, j;
  174. {
  175.     return((~i) & j);
  176. }
  177.  
  178. int
  179. andc2_op(i, j)
  180. int    i, j;
  181. {
  182.     return(i & (~j));
  183. }
  184.  
  185. int
  186. orc1_op(i, j)
  187. int    i, j;
  188. {
  189.     return((~i) | j);
  190. }
  191.  
  192. int
  193. orc2_op(i, j)
  194. int    i, j;
  195. {
  196.     return(i | (~j));
  197. }
  198.  
  199. b_clr_op(i, j)
  200. int    i, j;
  201. {
  202.     return(0);
  203. }
  204.  
  205. b_set_op(i, j)
  206. int    i, j;
  207. {
  208.     return(-1);
  209. }
  210.  
  211. b_1_op(i, j)
  212. int    i, j;
  213. {
  214.     return(i);
  215. }
  216.  
  217. b_2_op(i, j)
  218. int    i, j;
  219. {
  220.     return(j);
  221. }
  222.  
  223. b_c1_op(i, j)
  224. int    i, j;
  225. {
  226.     return(~i);
  227. }
  228.  
  229. b_c2_op(i, j)
  230. int    i, j;
  231. {
  232.     return(~j);
  233. }
  234.  
  235. int
  236. big_bitp(x, p)
  237. object    x;
  238. int    p;
  239. {
  240.     int    sign, cell, bit, i;
  241.  
  242.     if (p >= 0) {
  243.         cell = p / 31;
  244.         bit = p % 31;
  245.         while (cell-- > 0) {
  246.             if (x->big.big_cdr != NULL)
  247.                 x = (object)x->big.big_cdr;
  248.             else if (x->big.big_car < 0)
  249.                 return(1);
  250.             else
  251.                 return(0);
  252.         }
  253.         return((x->big.big_car >> bit) & 1);
  254.     } else
  255.         return(0);
  256. }
  257.  
  258. int
  259. fix_bitp(x, p)
  260. object    x;
  261. int    p;
  262. {
  263.     if (p > 30)        /* fix = sign + bit0-30 */
  264.         if (fix(x) < 0)
  265.             return(1);
  266.         else
  267.             return(0);
  268.     return((fix(x) >> p) & 1);
  269. }    
  270.  
  271. int
  272. count_int_bits(x)
  273. int    x;
  274. {
  275.     int    i, count;
  276.  
  277.     count = 0;
  278.     for (i=0; i < 31; i++) count += ((x >> i) & 1);
  279.     return(count);
  280. }
  281.  
  282. int
  283. count_bits(x)
  284. object    x;
  285. {
  286.     int    i, count, sign;
  287.  
  288.     if (type_of(x) == t_fixnum) {
  289.         i = fix(x);
  290.         if (i < 0) i = ~i;
  291.         count = count_int_bits(i);
  292.     } else if (type_of(x) == t_bignum) {
  293.         count = 0;
  294.         sign = big_sign(x);
  295.         for (;;) {
  296.             i = x->big.big_car;
  297.             if (sign < 0) i = ~i & MASK;
  298.             count += count_int_bits(i);
  299.             if (x->big.big_cdr == NULL) break;
  300.             x = (object)x->big.big_cdr;
  301.         }
  302.     } else
  303.         FEwrong_type_argument(Sinteger, x);
  304.     return(count);
  305. }
  306.  
  307. /*
  308.     double_shift(h, l, w, hp, lp) shifts the int h & l ( 31 bits)
  309.     w bits to left ( w > 0) or to right ( w < 0).
  310.     result is returned in *hp and *lp.
  311. */
  312. double_shift(h, l, w, hp, lp)
  313. int    h, l, w, *hp, *lp;
  314. {
  315.  
  316.     if (w >= 0) {
  317.         *lp = (l << w) & MASK;
  318.         *hp = ((h << w) & MASK) | ((l & MASK) >> (31 - w));
  319.     } else {
  320.         w = -w;
  321.         *hp = (h & MASK) >> w;
  322.         *lp = ((h << (31 - w)) & MASK) | ((l & MASK) >> w);
  323.     }
  324. }
  325.  
  326. object
  327. shift_integer(x, w)
  328. object    x;
  329. int    w;
  330. {
  331.     struct bignum *y, *y0;
  332.     object    r;
  333.     int    cell, bits, sign, i;
  334.     int    ext, h, l, nh, nl, end_x;
  335.     vs_mark;
  336.     
  337.     cell = w / 31;
  338.     bits = w % 31;
  339.     if (type_of(x) == t_fixnum) {
  340.         i = fix(x);
  341.         if (cell == 0) {
  342.             if (w < 0) {
  343.                 if (i >= 0)
  344.                     return(make_fixnum(i >> -w));
  345.                 else
  346.                     return(make_fixnum(~((~i) >> -w)));
  347.             } if (i >= 0) {
  348.                 if (((-1<<(31-w)) & i) == 0)
  349.                 /* if (((~MASK >> w) & i) == 0) */
  350.                     return(make_fixnum(i << w));
  351.             } else {
  352.                 if (w < 32 && ((-1<<(31-w)) & ~i) == 0)
  353.                 /* if (w < 32 && ((~MASK >> w) & ~i) == 0) */
  354.                     return(make_fixnum(i << w));
  355.             }
  356.         }
  357.         x = alloc_object(t_bignum);
  358.         x->big.big_car = i;
  359.         x->big.big_cdr = NULL;
  360.         vs_push(x);
  361.     }
  362.  
  363.     if ((sign = big_sign(x)) < 0)
  364.         ext = MASK;
  365.     else
  366.         ext = 0;
  367.  
  368.     y = y0 = (struct bignum *)alloc_object(t_bignum);
  369.     y->big_car = 0;
  370.     y->big_cdr = NULL;
  371.     vs_push(((object)y0));
  372.  
  373.     if (w < 0) goto RIGHT;
  374. LEFT:
  375.     while (cell-- > 0)
  376.         y = stretch_big(y, 0);
  377.     l = 0;
  378.     h = x->big.big_car;
  379.     end_x = 0;
  380.     goto COMMON;
  381.  
  382. RIGHT:
  383.     end_x = 0;
  384.     h = x->big.big_car;
  385.     while (cell++ <= 0) {
  386.         l = h;
  387.         if (end_x == 1) break;
  388.         if (x->big.big_cdr != NULL) {
  389.             x = (object)x->big.big_cdr;
  390.             h = x->big.big_car;
  391.         } else {
  392.             end_x = 1;
  393.             h = ext;
  394.         }
  395.     }
  396.  
  397. COMMON:
  398.     for (;;) {
  399.         double_shift(h, l, bits, &nh, &nl);
  400.         if (w < 0)
  401.             y->big_car = nl;
  402.         else
  403.             y->big_car = nh;
  404.         if (end_x == 1) break;
  405.         l = h;
  406.         if (x->big.big_cdr != NULL) {
  407.             x = (object)x->big.big_cdr;
  408.             h = x->big.big_car;
  409.         } else {
  410.             h = ext;
  411.             end_x = 1;
  412.         }
  413.         y = stretch_big(y, 0);
  414.     }
  415.     /* set sign bit */
  416.     if (sign < 0) y->big_car |= ~MASK;
  417.     r = normalize_big_to_object(y0);
  418.     vs_reset;
  419.     return(r);
  420. }
  421.  
  422. int
  423. int_bit_length(i)
  424. int    i;
  425. {
  426.     int    count, j;
  427.  
  428.     count = 0;
  429.     for (j = 0; j < 31 ; j++)
  430.         if (((i >> j) & 1) == 1) count = j + 1;
  431.     return(count);
  432. }
  433.  
  434. Llogior()
  435. {
  436.     object  x;
  437.     int    narg, i;
  438.     int    ior_op();
  439.  
  440.     narg = vs_top - vs_base;
  441.     for (i = 0; i < narg; i++)
  442.         check_type_integer(&vs_base[i]);
  443.     if (narg == 0) {
  444.         vs_top = vs_base;
  445.         vs_push(small_fixnum(0));
  446.         return;
  447.     }
  448.     if (narg == 1)
  449.         return;
  450.     x = log_op(ior_op);
  451.     vs_top = vs_base;
  452.     vs_push(x);
  453. }
  454.  
  455. Llogxor()
  456. {
  457.     object  x;
  458.     int    narg, i;
  459.     int    xor_op();
  460.  
  461.     narg = vs_top - vs_base;
  462.     for (i = 0; i < narg; i++)
  463.         check_type_integer(&vs_base[i]);
  464.     if (narg == 0) {
  465.         vs_top = vs_base;
  466.         vs_push(small_fixnum(0));
  467.         return;
  468.     }
  469.     if (narg == 1) return;
  470.     x = log_op(xor_op);
  471.     vs_top = vs_base;
  472.     vs_push(x);
  473. }
  474.  
  475. Llogand()
  476. {
  477.     object  x;
  478.     int    narg, i;
  479.     int    and_op();
  480.  
  481.     narg = vs_top - vs_base;
  482.     for (i = 0; i < narg; i++)
  483.         check_type_integer(&vs_base[i]);
  484.     if (narg == 0) {
  485.         vs_top = vs_base;
  486.         vs_push(small_fixnum(-1));
  487.         return;
  488.     }
  489.     if (narg == 1) return;
  490.     x = log_op(and_op);
  491.     vs_top = vs_base;
  492.     vs_push(x);
  493. }
  494.  
  495. Llogeqv()
  496. {
  497.     object  x;
  498.     int    narg, i;
  499.     int    eqv_op();
  500.  
  501.     narg = vs_top - vs_base;
  502.     for (i = 0; i < narg; i++)
  503.         check_type_integer(&vs_base[i]);
  504.     if (narg == 0) {
  505.         vs_top = vs_base;
  506.         vs_push(small_fixnum(-1));
  507.         return;
  508.     }
  509.     if (narg == 1) return;
  510.     x = log_op(eqv_op);
  511.     vs_top = vs_base;
  512.     vs_push(x);
  513. }
  514.  
  515. Lboole()
  516. {
  517.     object  x;
  518.     object    o, r;
  519.     int    (*op)();
  520.  
  521.     check_arg(3);
  522.     check_type_integer(&vs_base[0]);
  523.     check_type_integer(&vs_base[1]);
  524.     check_type_integer(&vs_base[2]);
  525.     o = vs_base[0];
  526.     switch(fixint(o)) {
  527.         case BOOLCLR:    op = b_clr_op;    break;
  528.         case BOOLSET:    op = b_set_op;    break;
  529.         case BOOL1:    op = b_1_op;    break;
  530.         case BOOL2:    op = b_2_op;    break;
  531.         case BOOLC1:    op = b_c1_op;    break;
  532.         case BOOLC2:    op = b_c2_op;    break;
  533.         case BOOLAND:    op = and_op;    break;
  534.         case BOOLIOR:    op = ior_op;    break;
  535.         case BOOLXOR:    op = xor_op;    break;
  536.         case BOOLEQV:    op = eqv_op;    break;
  537.         case BOOLNAND:    op = nand_op;    break;
  538.         case BOOLNOR:    op = nor_op;    break;
  539.         case BOOLANDC1:    op = andc1_op;    break;
  540.         case BOOLANDC2:    op = andc2_op;    break;
  541.         case BOOLORC1:    op = orc1_op;    break;
  542.         case BOOLORC2:    op = orc2_op;    break;
  543.         default:
  544.             FEerror("~S is an invalid logical operator.",
  545.                 1, o);
  546.     }
  547.     vs_base++;
  548.     x = log_op(op);
  549.     vs_base--;
  550.     vs_top = vs_base;
  551.     vs_push(x);
  552. }
  553.  
  554. Llogbitp()
  555. {
  556.     object    x, p;
  557.     int    i;
  558.  
  559.     check_arg(2);
  560.     check_type_integer(&vs_base[0]);
  561.     check_type_integer(&vs_base[1]);
  562.     p = vs_base[0];
  563.     x = vs_base[1];
  564.     if (type_of(p) == t_fixnum)
  565.         if (type_of(x) == t_fixnum)
  566.             i = fix_bitp(x, fix(p));
  567.         else
  568.             i = big_bitp(x, fix(p));
  569.     else if (big_sign(p) < 0)
  570.             i = 0;
  571.         /*
  572.            bit position represented by bignum is out of
  573.            our address space. So, result is returned
  574.            according to sign of integer.
  575.         */
  576.  
  577.     else if (type_of(x) == t_fixnum)
  578.         if (fix(x) < 0)
  579.             i = 1;
  580.         else
  581.             i = 0;
  582.     else if (big_sign(x) < 0)
  583.             i = 1;
  584.         else
  585.             i = 0;
  586.  
  587.     vs_top = vs_base;
  588.     if (i == 1)
  589.         vs_push(Ct);
  590.     else
  591.         vs_push(Cnil);
  592. }
  593.  
  594. Lash()
  595. {
  596.     object    r, x, y;
  597.     int    w, sign_x;
  598.  
  599.     check_arg(2);
  600.         check_type_integer(&vs_base[0]);
  601.     check_type_integer(&vs_base[1]);
  602.     x = vs_base[0];
  603.     y = vs_base[1];
  604.     if (type_of(y) == t_fixnum) {
  605.         w = fix(y);
  606.         r = shift_integer(x, w);
  607.     } else if (type_of(y) == t_bignum)
  608.         goto LARGE_SHIFT;
  609.     else
  610.         ;
  611.     goto BYE;
  612.  
  613.     /*
  614.     bit position represented by bignum is probably
  615.     out of our address space. So, result is returned
  616.     according to sign of integer.
  617.     */
  618. LARGE_SHIFT:
  619.     if (type_of(x) == t_fixnum)
  620.         if (fix(x) > 0)
  621.             sign_x = 1;
  622.         else if (fix(x) == 0)
  623.             sign_x = 0;
  624.         else
  625.             sign_x = -1;
  626.     else
  627.         sign_x = big_sign(x);
  628.     if (big_sign(y) < 0)
  629.         if (sign_x < 0)
  630.             r = small_fixnum(-1);
  631.         else
  632.             r = small_fixnum(0);
  633.     else if (sign_x == 0)
  634.         r = small_fixnum(0);
  635.     else
  636.         FEerror("Insufficient memory.", 0);
  637.  
  638. BYE:
  639.     vs_top = vs_base;
  640.     vs_push(r);
  641. }
  642.  
  643. Llogcount()
  644. {
  645.     object    x;
  646.     int    i;
  647.  
  648.     check_arg(1);
  649.     check_type_integer(&vs_base[0]);
  650.     x = vs_base[0];
  651.     i = count_bits(x);
  652.     vs_top = vs_base;
  653.     vs_push(make_fixnum(i));
  654. }
  655.  
  656. Linteger_length()
  657. {
  658.     object    x;
  659.     int    count, cell, i;
  660.  
  661.     check_arg(1);
  662.     check_type_integer(&vs_base[0]);
  663.     x = vs_base[0];
  664.     if (type_of(x) == t_fixnum) {
  665.         i = fix(x);
  666.         if (i < 0) i = ~i;
  667.         count = int_bit_length(i);
  668.     } else if (type_of(x) == t_bignum) {
  669.         cell = 0;
  670.         while(x->big.big_cdr != NULL) {
  671.             cell++;
  672.             x = (object)x->big.big_cdr;
  673.         }
  674.         i = x->big.big_car;
  675.         if (i < 0) i = ~i;
  676.         count = cell * 31 + int_bit_length(i);
  677.     } else
  678.         ;
  679.     vs_top = vs_base;
  680.     vs_push(make_fixnum(count));
  681. }
  682.  
  683.  
  684. object Sbit;
  685.  
  686. init_num_log()
  687. {
  688.     int siLbit_array_op();
  689.  
  690.     make_constant("BOOLE-CLR", make_fixnum(BOOLCLR));
  691.     make_constant("BOOLE-SET", make_fixnum(BOOLSET));
  692.     make_constant("BOOLE-1", make_fixnum(BOOL1));
  693.     make_constant("BOOLE-2", make_fixnum(BOOL2));
  694.     make_constant("BOOLE-C1", make_fixnum(BOOLC1));
  695.     make_constant("BOOLE-C2", make_fixnum(BOOLC2));
  696.     make_constant("BOOLE-AND", make_fixnum(BOOLAND));
  697.     make_constant("BOOLE-IOR", make_fixnum(BOOLIOR));
  698.     make_constant("BOOLE-XOR", make_fixnum(BOOLXOR));
  699.     make_constant("BOOLE-EQV", make_fixnum(BOOLEQV));
  700.     make_constant("BOOLE-NAND", make_fixnum(BOOLNAND));
  701.     make_constant("BOOLE-NOR", make_fixnum(BOOLNOR));
  702.     make_constant("BOOLE-ANDC1", make_fixnum(BOOLANDC1));
  703.     make_constant("BOOLE-ANDC2", make_fixnum(BOOLANDC2));
  704.     make_constant("BOOLE-ORC1", make_fixnum(BOOLORC1));
  705.     make_constant("BOOLE-ORC2", make_fixnum(BOOLORC2));
  706.  
  707.     make_function("LOGIOR", Llogior);
  708.     make_function("LOGXOR", Llogxor);
  709.     make_function("LOGAND", Llogand);
  710.     make_function("LOGEQV", Llogeqv);
  711.     make_function("BOOLE", Lboole);
  712.     make_function("LOGBITP", Llogbitp);
  713.     make_function("ASH", Lash);
  714.     make_function("LOGCOUNT", Llogcount);
  715.     make_function("INTEGER-LENGTH", Linteger_length);
  716.  
  717.     Sbit = make_ordinary("BIT");
  718.     make_si_function("BIT-ARRAY-OP", siLbit_array_op);
  719. }
  720.  
  721.  
  722. siLbit_array_op()
  723. {
  724.     int i, j, n, d;
  725.     object  o, x, y, r, r0;
  726.     int (*op)();
  727.     bool replace = FALSE;
  728.     int xi, yi, ri;
  729.     char *xp, *yp, *rp;
  730.     int xo, yo, ro;
  731.     object *base = vs_base;
  732.  
  733.     check_arg(4);
  734.     o = vs_base[0];
  735.     x = vs_base[1];
  736.     y = vs_base[2];
  737.     r = vs_base[3];
  738.     if (type_of(x) == t_bitvector) {
  739.         d = x->bv.bv_dim;
  740.         xp = x->bv.bv_self;
  741.         xo = x->bv.bv_offset;
  742.         if (type_of(y) != t_bitvector)
  743.             goto ERROR;
  744.         if (d != y->bv.bv_dim)
  745.             goto ERROR;
  746.         yp = y->bv.bv_self;
  747.         yo = y->bv.bv_offset;
  748.         if (r == Ct)
  749.             r = x;
  750.         if (r != Cnil) {
  751.             if (type_of(r) != t_bitvector)
  752.                 goto ERROR;
  753.             if (r->bv.bv_dim != d)
  754.                 goto ERROR;
  755.             i = (r->bv.bv_self - xp)*8 + (r->bv.bv_offset - xo);
  756.             if (i > 0 && i < d || i < 0 && -i < d) {
  757.                 r0 = r;
  758.                 r = Cnil;
  759.                 replace = TRUE;
  760.                 goto L1;
  761.             }
  762.             i = (r->bv.bv_self - yp)*8 + (r->bv.bv_offset - yo);
  763.             if (i > 0 && i < d || i < 0 && -i < d) {
  764.                 r0 = r;
  765.                 r = Cnil;
  766.                 replace = TRUE;
  767.             }
  768.         }
  769.     L1:
  770.         if (r == Cnil) {
  771.             vs_base = vs_top;
  772.             vs_push(Sbit);
  773.             vs_push(make_fixnum(d));
  774.             vs_push(Cnil);
  775.             vs_push(Cnil);
  776.             vs_push(Cnil);
  777.             vs_push(Cnil);
  778.             vs_push(Cnil);
  779.             siLmake_vector();
  780.             r = vs_base[0];
  781.         }
  782.     } else {
  783.         if (type_of(x) != t_array)
  784.             goto ERROR;
  785.         if ((enum aelttype)x->a.a_elttype != aet_bit)
  786.             goto ERROR;
  787.         d = x->a.a_dim;
  788.         xp = x->bv.bv_self;
  789.         xo = x->bv.bv_offset;
  790.         if (type_of(y) != t_array)
  791.             goto ERROR;
  792.         if ((enum aelttype)y->a.a_elttype != aet_bit)
  793.             goto ERROR;
  794.         if (x->a.a_rank != y->a.a_rank)
  795.             goto ERROR;
  796.         yp = y->bv.bv_self;
  797.         yo = y->bv.bv_offset;
  798.         for (i = 0;  i < x->a.a_rank;  i++)
  799.             if (x->a.a_dims[i] != y->a.a_dims[i])
  800.                 goto ERROR;
  801.         if (r == Ct)
  802.             r = x;
  803.         if (r != Cnil) {
  804.             if (type_of(r) != t_array)
  805.                 goto ERROR;
  806.             if ((enum aelttype)r->a.a_elttype != aet_bit)
  807.                 goto ERROR;
  808.             if (r->a.a_rank != x->a.a_rank)
  809.                 goto ERROR;
  810.             for (i = 0;  i < x->a.a_rank;  i++)
  811.                 if (r->a.a_dims[i] != x->a.a_dims[i])
  812.                     goto ERROR;
  813.             i = (r->bv.bv_self - xp)*8 + (r->bv.bv_offset - xo);
  814.             if (i > 0 && i < d || i < 0 && -i < d) {
  815.                 r0 = r;
  816.                 r = Cnil;
  817.                 replace = TRUE;
  818.                 goto L2;
  819.             } 
  820.             i = (r->bv.bv_self - yp)*8 + (r->bv.bv_offset - yo);
  821.             if (i > 0 && i < d || i < 0 && -i < d) {
  822.                 r0 = r;
  823.                 r = Cnil;
  824.                 replace = TRUE;
  825.             }
  826.         }
  827.     L2:
  828.         if (r == Cnil) {
  829.             vs_base = vs_top;
  830.             vs_push(Sbit);
  831.             vs_push(Cnil);
  832.             vs_push(Cnil);
  833.             vs_push(Cnil);
  834.             vs_push(Cnil);
  835.             for (i = 0;  i < x->a.a_rank;  i++)
  836.                 vs_push(make_fixnum(x->a.a_dims[i]));
  837.             siLmake_pure_array();
  838.             r = vs_base[0];
  839.         }
  840.     }
  841.     rp = r->bv.bv_self;
  842.     ro = r->bv.bv_offset;
  843.     switch(fixint(o)) {
  844.         case BOOLCLR:    op = b_clr_op;    break;
  845.         case BOOLSET:    op = b_set_op;    break;
  846.         case BOOL1:    op = b_1_op;    break;
  847.         case BOOL2:    op = b_2_op;    break;
  848.         case BOOLC1:    op = b_c1_op;    break;
  849.         case BOOLC2:    op = b_c2_op;    break;
  850.         case BOOLAND:    op = and_op;    break;
  851.         case BOOLIOR:    op = ior_op;    break;
  852.         case BOOLXOR:    op = xor_op;    break;
  853.         case BOOLEQV:    op = eqv_op;    break;
  854.         case BOOLNAND:    op = nand_op;    break;
  855.         case BOOLNOR:    op = nor_op;    break;
  856.         case BOOLANDC1:    op = andc1_op;    break;
  857.         case BOOLANDC2:    op = andc2_op;    break;
  858.         case BOOLORC1:    op = orc1_op;    break;
  859.         case BOOLORC2:    op = orc2_op;    break;
  860.         default:
  861.             FEerror("~S is an invalid logical operator.", 1, o);
  862.     }
  863.  
  864. #define    set_high(place, nbits, value) \
  865.     ((place)=((place)&~(-0400>>(nbits))|(value)&(-0400>>(nbits))))
  866.  
  867. #define    set_low(place, nbits, value) \
  868.     ((place)=((place)&(-0400>>(8-(nbits)))|(value)&~(-0400>>(8-(nbits)))))
  869.  
  870. #define    extract_byte(integer, pointer, index, offset) \
  871.     (integer) = (pointer)[(index)+1] & 0377; \
  872.     (integer) = ((pointer)[index]<<(offset))|((integer)>>(8-(offset)))
  873.  
  874. #define    store_byte(pointer, index, offset, value) \
  875.     set_low((pointer)[index], 8-(offset), (value)>>(offset)); \
  876.     set_high((pointer)[(index)+1], offset, (value)<<(8-(offset)))
  877.  
  878.     if (xo == 0 && yo == 0 && ro == 0) {
  879.         for (n = d/8, i = 0;  i < n;  i++)
  880.             rp[i] = (*op)(xp[i], yp[i]);
  881.         if ((j = d%8) > 0)
  882.             set_high(rp[n], j, (*op)(xp[n], yp[n]));
  883.         if (!replace) {
  884.             vs_top = vs_base = base;
  885.             vs_push(r);
  886.             return;
  887.         }
  888.     } else {
  889.         for (n = d/8, i = 0;  i <= n;  i++) {
  890.             extract_byte(xi, xp, i, xo);
  891.             extract_byte(yi, yp, i, yo);
  892.             if (i == n) {
  893.                 if ((j = d%8) == 0)
  894.                     break;
  895.                 extract_byte(ri, rp, n, ro);
  896.                 set_high(ri, j, (*op)(xi, yi));
  897.             } else
  898.                 ri = (*op)(xi, yi);
  899.             store_byte(rp, i, ro, ri);
  900.         }
  901.         if (!replace) {
  902.             vs_top = vs_base = base;
  903.             vs_push(r);
  904.             return;
  905.         }
  906.     }
  907.     rp = r0->bv.bv_self;
  908.     ro = r0->bv.bv_offset;
  909.     for (n = d/8, i = 0;  i <= n;  i++) {
  910.         if (i == n) {
  911.             if ((j = d%8) == 0)
  912.                 break;
  913.             extract_byte(ri, rp, n, ro);
  914.             set_high(ri, j, r->bv.bv_self[n]);
  915.         } else
  916.             ri = r->bv.bv_self[i];
  917.         store_byte(rp, i, ro, ri);
  918.     }
  919.     vs_top = vs_base = base;
  920.     vs_push(r0);
  921.     return;
  922.  
  923. ERROR:
  924.     FEerror("Illegal arguments for bit-array operation.", 0);
  925. }
  926.